home *** CD-ROM | disk | FTP | other *** search
- /* ******************************************************************** */
- /* basic.c Copyright (C) Codemist and University of Bath 1989 */
- /* */
- /* Basic functions */
- /* ******************************************************************** */
-
- /*
- * Change Log:
- * Version 1, April 1989
- * Add many functions - JPff
- * Add rplaca & rplacd - RJB
- * Add defmacro - JPff
- * Introduce GC protection in places - JPff
- * Wrote NREVERSE for fun - JPff
- * and ASSOC - JPff
- * Moved basic.c to generic.c - JPff
- * Add defconstant and mutability in bindings - JPff
- * Hacked car & cons on the nil case and fixed the consp
- * make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
- * Altered defun so that its body is a list of forms - (25/10/89) KJP
- */
-
-
- #include "defs.h"
- #include "structs.h"
- #include "funcalls.h"
-
- #include "error.h"
- #include "global.h"
-
- #include "modboot.h"
- #include "specials.h"
-
- EUFUN_1( Fn_atom, form)
- {
- return (is_cons(form) ? nil : lisptrue);
- }
- EUFUN_CLOSE
-
- void printoblist(LispObject *stacktop)
- { /* Broke */
- LispObject ob = (LispObject) ObList;
- while (ob!=NULL) {
- EUCALL_2(Fn_print,ob, StdErr);
- ob = (LispObject) (ob->SYMBOL).left;
- }
- }
-
- EUFUN_0 (Fn_oblist)
- {
- printoblist(stacktop);
- return nil;
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_consn, n)
- {
- int i;
- LispObject l = nil;
-
- for (i = intval(n); i > 0; --i) {
- ARG_1(stacktop) = l;
- ARG_0(stacktop) = nil;
- l = Fn_cons(stacktop);
- }
-
- return(l);
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_system, str)
- {
- extern int system(char *);
-
- if (!is_string(str))
- CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
-
- (void) system(stringof(str));
-
- return(nil);
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_getenv, str)
- {
- extern char *getenv(char *);
- extern int strlen(char *);
- char *value;
-
- if (!is_string(str))
- CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
-
- value = getenv(stringof(str));
-
- if (value == NULL) return(nil);
-
- return((LispObject) allocate_string(stacktop,value,strlen(value)));
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_exit)
- {
- fprintf(StdOut->STREAM.handle,"\n\nExiting EuLisp\n\n");
-
- exit(0);
-
- return(nil);
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_make_map)
- {
- extern void make_map(void);
-
- make_map();
-
- return(nil);
- }
- EUFUN_CLOSE
-
- /* Time... */
-
- #include <sys/types.h>
-
- EUFUN_0( Fn_system_time)
- {
- extern long time(long *);
- long n;
-
- (void) time(&n);
- return(allocate_integer(stackbase, (int) n));
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_process_id)
- {
- extern int getpid(void);
-
- return(allocate_integer(stackbase, getpid()));
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_backtrace)
- {
- extern void module_eval_backtrace(void);
- module_eval_backtrace();
- return(nil);
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_cpu_time)
- {
- extern long clock(void);
-
- return(allocate_integer(stackbase, (int)(clock()/10000)));
- }
- EUFUN_CLOSE
-
- EUFUN_0( Fn_rand)
- {
- extern int rand(void);
-
- return(allocate_integer(stackbase, rand()));
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_srand, s)
- {
- extern void srand(unsigned int);
-
- srand((unsigned int) intval(s));
-
- return(nil);
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_system_describe, obj)
- {
- printf("Address: %x\n",(int) obj);
- printf("Type: %x\n",typeof(obj));
- printf("GC: %x\n",gcof(obj));
- printf("Class: %x\n",(int) classof(obj));
- fflush(stdout);
- return(nil);
- }
- EUFUN_CLOSE
-
- /* Weak pointers... */
-
- extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
-
- EUFUN_1( Fn_make_weak_wrapper, obj)
- {
- return(allocate_weak_wrapper(stackbase, obj));
- }
- EUFUN_CLOSE
-
- EUFUN_1( Fn_weak_wrapper_ref, w)
- {
- if (!is_weak_wrapper(w))
- CallError(stacktop,
- "weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
-
- return(w->WEAK_WRAPPER.object);
- }
- EUFUN_CLOSE
-
- EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
- {
- if (!is_weak_wrapper(w))
- CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
- w,NONCONTINUABLE);
-
- w->WEAK_WRAPPER.object = obj;
-
- return(obj);
- }
- EUFUN_CLOSE
-
- /* *************************************************************** */
- /* Initialisation of this section */
- /* *************************************************************** */
-
- void initialise_basic(LispObject *stacktop)
- {
- LispObject get,set;
-
- (void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
- get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
- STACK_TMP(get);
- set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
- Fn_dynamic_setq,2);
- UNSTACK_TMP(get);
- set_anon_associate(stacktop,get,set);
-
- (void) make_module_function(stacktop,"atom",Fn_atom,1);
- (void) make_module_function(stacktop,"oblist", Fn_oblist, 0);
- (void) make_module_function(stacktop,"consn", Fn_consn, 1);
- (void) make_module_function(stacktop,"system",Fn_system,1);
- (void) make_module_function(stacktop,"getenv",Fn_getenv,1);
- (void) make_module_function(stacktop,"exit",Fn_exit,0);
- (void) make_module_function(stacktop,"make-map",Fn_make_map,0);
- (void) make_module_function(stacktop,"system-time",Fn_system_time,0);
- (void) make_module_function(stacktop,"process-id",Fn_process_id,0);
- (void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
- (void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
- (void) make_module_function(stacktop,"c-rand",Fn_rand,0);
- (void) make_module_function(stacktop,"c-srand",Fn_srand,1);
-
- (void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
-
- (void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
- get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
- STACK_TMP(get);
- set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
- Fn_weak_wrapper_ref_setter,2);
- UNSTACK_TMP(get);
- set_anon_associate(stacktop,get,set);
- }
-